home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 008 / rle.arc / RLE.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1986-04-25  |  3.1 KB  |  140 lines
  1. {
  2.  
  3.            RLE.PAS  - Written by Wes Meier (76703,747).
  4.                       Version 1.00   -   4/25/86.
  5.  
  6.                       Based on Dick McCaleb's (72236,3206) April 1986
  7.                       RLE decoder for the TRS-80 Color Computer.
  8.  
  9.  
  10.                       ---> for Public Domain Only <---
  11.  
  12. }
  13.  
  14. type
  15.   str255 = string[255];
  16.  
  17. var
  18.   filename : file of byte;
  19.   sx       : str255;
  20.  
  21. Procedure Instruct;
  22.   begin
  23.     writeln('RLE: Run Length Encoded Graphics Decoder. Version 1.00 4/25/86.');
  24.     writeln('     by Wes Meier [76703,747].');
  25.     writeln('     for Public Domain ONLY');
  26.     writeln;
  27.     writeln('Usage: RLE filespec[.RLE]')
  28.   end; { Proc Instruct }
  29.  
  30.  
  31. Procedure GetFile(sf : str255);
  32.   Var
  33.     i  : integer;
  34.  
  35.   Begin
  36.     for i := 1 to length(sf) do sf[i] := upcase(sf[i]);
  37.     if pos('.',sf) = 0 then sf := sf + '.RLE';
  38.     Assign(Filename,sf);
  39.     {$I- }
  40.       Reset(Filename);
  41.     {$I+ }
  42.     If IOResult > 0
  43.       then
  44.         Begin
  45.           Writeln('File "',sf,'" wasn',#39,'t found.');
  46.           Halt
  47.         End { if }
  48.   End; { Proc GetFile }
  49.  
  50. Procedure Decode;
  51.   label loop;
  52.  
  53.   var
  54.     x,
  55.     y,
  56.     tc,
  57.     w,
  58.     i,
  59.     j   : integer;
  60.     b   : byte;
  61.     Ok  : boolean;
  62.  
  63.   Begin
  64.     tc := 1;
  65.     GraphColorMode;
  66.     GraphBackground(0);
  67.     GraphWindow(32,0,319,199);
  68.     Palette(1);
  69.     x := 0;
  70.     y := 0;
  71.     loop:
  72.        read(filename,b);
  73.        if b <> 27 then goto loop;
  74.        read(filename,b);
  75.        if b <> ord('G') then goto loop;
  76.        read(filename,b);
  77.        if b <> ord('H') then goto loop;
  78.     Ok := true;
  79.     Repeat { until NOT Ok or EOF }
  80.       read(filename,b);
  81.       b := b - 32;
  82.       Ok := (b >= 0);
  83.       if Ok
  84.         then
  85.           Begin
  86.             x := x + b;
  87.             if x > 255
  88.               then
  89.                 begin
  90.                   y := y + 1;
  91.                   x := x mod 256
  92.                 end; { if x }
  93.             if not EOF(filename)
  94.               then
  95.                 read(filename,b)
  96.               else
  97.                 b := 0;
  98.             w := b - 32;
  99.             Ok := (w >= 0);
  100.             if Ok and (w > 0)
  101.               then
  102.                 begin
  103.                   j := w + x - 1;
  104.                   if j > 255
  105.                     then
  106.                       begin
  107.                         draw(x,y,255,y,tc);
  108.                         i := y + 1;
  109.                         j := j mod 256;
  110.                         draw(0,i,j,i,tc);
  111.                         x := x + w
  112.                       end { if j }
  113.                     else
  114.                       begin
  115.                         draw(x,y,j,y,tc);
  116.                         x := x + w
  117.                       end { else if j }
  118.                 end { if Ok and (w > 0) }
  119.           end { if ok }
  120.     Until not Ok or EOF(filename);
  121.     Close(Filename)
  122.   End; { Proc Decode }
  123.  
  124. Begin        { Main }
  125.   lowvideo;
  126.   if paramcount = 0
  127.     then
  128.       instruct
  129.     else
  130.       begin
  131.         getfile(paramstr(1));
  132.         decode;
  133.         sound(440);
  134.         delay(250);
  135.         Nosound;
  136.         repeat until keypressed;
  137.         textmode
  138.      end { else }
  139. End.
  140.